Mental Health Continuum

Author
Affiliation
Magnus Johansson
Published

August 28, 2023

Code
# recode response categories to numerics
df <- df %>% 
  mutate(across(starts_with("I1_"), ~ recode(.x,"'Aldrig'=0;
                    'En eller två gånger'=1;
                    '1 gång/vecka'=2;
                    '2-3 gånger/vecka'=3;
                    'Nästan dagligen'=4;
                    'Dagligen'=5",
                    as.factor = FALSE)
  ))

# koda om "Hur mår du rent allmänt?"
df <- df %>% 
  mutate(A1num = recode(A1,"'Mycket dåligt'=0;
                    'Dåligt'=1;
                    'Varken bra eller dåligt'=2;
                    'Bra'=3;
                    'Mycket bra'=4",
                    as.factor = FALSE)
  )
Code
# filter relevant variables, only respondents from 2019 with complete response data
df.omit.na <- df %>% 
  filter(inars %in% c(2019)) %>% 
  mutaterskurs = recode(arskurs,"1='Åk 7';2='Åk 9';3='Gy 2';9=NA;99=NA", as.factor = TRUE),
         Kön = recode(kon,"99=NA;9=NA;2='Flickor';1='Pojkar'", as.factor = T),
         Skolkommun = recode(skolkommun,"1='Enköping';2='Heby';3='Håbo';4='Knivsta';
                             5='Tierp';6='Uppsala';7='Älvkarleby';8='Östhammar'", as.factor = T)
         #across(everything(), ~na_if(., ""))
         ) %>% 
  select(starts_with("I1_"),Årskurs,Kön,Skolkommun) %>% 
  na.omit()

# create variables for analysis of Differential Item Functioning
dif.arskurs <- df.omit.na$Årskurs
dif.gender <- df.omit.na$Kön
dif.skolkommun <- df.omit.na$Skolkommun

df.omit.na$Årskurs <- NULL
df.omit.na$Kön <- NULL
df.omit.na$Skolkommun <- NULL

names(df.omit.na) <- itemlabels$itemnr

1 Demografiska data

Code
RIdemographics(dif.gender, "Kön")
RIdemographics(dif.arskurs, "Årskurs")
RIdemographics(dif.skolkommun, "Skolkommun")
Kön n Percent
Flickor 2798 49
Pojkar 2909 51
Årskurs n Percent
Åk 7 2029 35.6
Åk 9 2097 36.7
Gy 2 1581 27.7
Skolkommun n Percent
Älvkarleby 91 1.6
Enköping 572 10.0
Håbo 466 8.2
Heby 147 2.6
Knivsta 298 5.2
Östhammar 311 5.4
Tierp 312 5.5
Uppsala 3510 61.5

2 Deskriptiva data

Bakgrund om MHC kommer läggas till i kortfattat utförande.

Svarskategorierna som använts i enkäten och deras omkodning till siffror:

  • Aldrig = 0
  • En eller två gånger = 1
  • 1 gång/vecka = 2
  • 2-3 gånger/vecka = 3
  • Nästan dagligen = 4
  • Dagligen = 5
Code
RIallresp(df.omit.na)
Response category Number of responses Percent
0 10161 12.7
1 8721 10.9
2 8312 10.4
3 13460 16.8
4 19298 24.2
5 19946 25.0

Totalt antal svar per svarskategori för alla items

2.1 Descriptives - item level

itemnr item
mhc1 lycka, glädje
mhc2 ett intresse för livet (att livet engagerar)
mhc3 dig nöjd/tillfredsställd
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc7 att människor i grunden är goda
mhc8 att det sätt som samhället fungerar på verkar begripligt
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RItileplot(df.omit.na)

Code
RIbarstack(df.omit.na)

Code
RIbarplot(df.omit.na)

2.2 Tak/golv-effekt, rådata

Code
RIrawdist(df.omit.na)

3 Rasch-analys 1

The eRm package, which uses Conditional Maximum Likelihood (CML) estimation, will be used with the Partial Credit Model (PCM).

itemnr item
mhc1 lycka, glädje
mhc2 ett intresse för livet (att livet engagerar)
mhc3 dig nöjd/tillfredsställd
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc7 att människor i grunden är goda
mhc8 att det sätt som samhället fungerar på verkar begripligt
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIitemfitPCM2(df.omit.na, 250, 32, 8)
OutfitMSQ InfitMSQ OutfitZSTD InfitZSTD
mhc1 0.856 0.851 -1.761 -1.348
mhc2 0.77 0.768 -2.776 -2.78
mhc3 0.796 0.788 -2.438 -2.468
mhc4 1.599 1.405 4.9 3.633
mhc5 1.311 1.179 1.69 1.758
mhc6 1.151 1.088 0.966 1.13
mhc7 1.074 1.048 0.83 0.727
mhc8 1.123 1.108 0.948 1.172
mhc9 0.728 0.741 -2.368 -2.871
mhc10 0.988 0.959 0.016 -0.577
mhc11 0.844 0.825 -1.507 -1.74
mhc12 0.967 0.947 -0.095 -0.937
mhc13 0.874 0.912 -1.146 -0.9
mhc14 0.713 0.733 -3.03 -3.02
Code
RIpcmPCA(df.omit.na)
PCA of Rasch model residuals
Eigenvalues
2.39
1.78
1.32
1.24
1.05
Code
RIresidcorr(df.omit.na, cutoff = 0.2)
mhc1 mhc2 mhc3 mhc4 mhc5 mhc6 mhc7 mhc8 mhc9 mhc10 mhc11 mhc12 mhc13 mhc14
mhc1
mhc2 0.4
mhc3 0.43 0.4
mhc4 -0.17 -0.13 -0.11
mhc5 -0.03 -0.07 -0.04 -0.03
mhc6 -0.19 -0.19 -0.2 -0.01 -0.11
mhc7 -0.17 -0.2 -0.22 -0.14 -0.1 0.24
mhc8 -0.21 -0.25 -0.24 -0.13 -0.1 0.29 0.3
mhc9 -0.03 -0.03 -0.01 -0.19 -0.16 -0.18 -0.16 -0.15
mhc10 -0.14 -0.11 -0.1 -0.13 -0.15 -0.15 -0.14 -0.09 0.05
mhc11 -0.01 -0.1 -0.06 -0.18 0.07 -0.23 -0.1 -0.18 0.02 0.05
mhc12 -0.17 -0.17 -0.18 -0.04 -0.17 -0.13 -0.15 -0.13 -0.07 0.02 0.04
mhc13 -0.12 -0.15 -0.13 -0.06 -0.11 -0.21 -0.2 -0.18 0.13 -0.04 -0.02 0.1
mhc14 -0.08 0.09 -0.03 -0.11 -0.19 -0.2 -0.18 -0.2 0.07 0.03 -0.06 0.06 0.07
Note:
Relative cut-off value (highlighted in red) is 0.13, which is 0.2 above the average correlation.
Code
RIloadLoc(df.omit.na)

Code
RIitemCats(df.omit.na)

Code
RItargeting(df.omit.na)

Code
RIitemHierarchy(df.omit.na)

Item 4 har hög item fit.

PCA av residualerna ger ett största eigenvalue på över 2.0, vilket indikerar att det finns mer än en dimension i data.

Residualkorrelationerna visar på två kluster, ett som består av items 1-3 och ett med items 6-8.

Items 4, 6, 7 och 8 har alla att göra med upplevelser av samhället och gemenskap och hänger samman med varandra i ett kluster. Item 4 ligger något närmare övriga items än vad 6-8 gör.

Samtliga items har problem med oordnade svarskategorier. Det innebär att respondenterna inte skiljer på svarskategorierna på ett systematiskt och tydligt sätt, och att de inte bidrar med meningsfull information i sin nuvarande form. Det kan antingen bero på att det är för många svarskategorier eller att svarskategoriernas etiketter är för “nära” varandra.

Svarskategorierna som använts i enkäten är:

  • Aldrig = 0
  • En eller två gånger = 1
  • 1 gång/vecka = 2
  • 2-3 gånger/vecka = 3
  • Nästan dagligen = 4
  • Dagligen = 5

Vi slår samman kategori 0+1 och 2+3.

3.1 Sammanslagning av svarskategorier

Code
for (i in itemlabels$itemnr) {
  df.omit.na[[i]] <- recode(df.omit.na[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}
Code
RItileplot(df.omit.na)

Code
RIitemCats(df.omit.na)

Nu är alla items svarskategorier ordnade, även om det är väldigt små avstånd mellan många tröskelvärden. Figuren nedan under “itemhierarki” visar 95% konfidensintervall runt varje items trösklar.

Vi kör om analysen för att se hur detta påverkat övriga parametrar.

4 Rasch-analys 2

itemnr item
mhc1 lycka, glädje
mhc2 ett intresse för livet (att livet engagerar)
mhc3 dig nöjd/tillfredsställd
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc7 att människor i grunden är goda
mhc8 att det sätt som samhället fungerar på verkar begripligt
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIitemfitPCM2(df.omit.na, 250, 32, 8)
OutfitMSQ InfitMSQ OutfitZSTD InfitZSTD
mhc1 0.902 0.874 -0.867 -1.519
mhc2 0.794 0.787 -2.072 -2.625
mhc3 0.787 0.781 -2.641 -2.992
mhc4 1.475 1.327 3.038 2.926
mhc5 1.263 1.168 2.084 1.384
mhc6 1.077 1.012 0.53 0.108
mhc7 1.076 1.029 0.781 0.463
mhc8 1.083 1.046 0.435 0.664
mhc9 0.742 0.752 -2.899 -2.817
mhc10 1.065 0.997 0.328 -0.103
mhc11 0.872 0.858 -1.133 -1.653
mhc12 1.024 0.996 0.556 0.067
mhc13 0.97 0.955 -0.343 -0.499
mhc14 0.74 0.752 -2.46 -3.004
Code
RIpcmPCA(df.omit.na)
PCA of Rasch model residuals
Eigenvalues
2.19
1.80
1.32
1.25
1.08
Code
RIresidcorr(df.omit.na, cutoff = 0.2)
mhc1 mhc2 mhc3 mhc4 mhc5 mhc6 mhc7 mhc8 mhc9 mhc10 mhc11 mhc12 mhc13 mhc14
mhc1
mhc2 0.34
mhc3 0.38 0.35
mhc4 -0.16 -0.13 -0.1
mhc5 -0.05 -0.08 -0.05 -0.04
mhc6 -0.16 -0.15 -0.17 0 -0.1
mhc7 -0.15 -0.17 -0.2 -0.1 -0.1 0.25
mhc8 -0.19 -0.21 -0.2 -0.1 -0.11 0.28 0.29
mhc9 -0.06 -0.07 -0.04 -0.17 -0.16 -0.13 -0.12 -0.1
mhc10 -0.16 -0.13 -0.14 -0.13 -0.15 -0.12 -0.13 -0.08 0.03
mhc11 -0.04 -0.11 -0.09 -0.18 0.09 -0.21 -0.1 -0.16 -0.01 0.03
mhc12 -0.19 -0.19 -0.2 -0.02 -0.17 -0.11 -0.14 -0.12 -0.08 0.02 0
mhc13 -0.15 -0.18 -0.16 -0.04 -0.1 -0.19 -0.19 -0.16 0.1 -0.07 -0.05 0.09
mhc14 -0.12 0.05 -0.07 -0.09 -0.18 -0.16 -0.17 -0.17 0.04 0.01 -0.08 0.04 0.06
Note:
Relative cut-off value (highlighted in red) is 0.127, which is 0.2 above the average correlation.
Code
RIloadLoc(df.omit.na)

Code
# increase fig-height above as needed, if you have many items
RItargeting(df.omit.na)

Code
RIitemHierarchy(df.omit.na)

Vi ser samma klustring i residualkorrelationerna av items 1-3. Samtliga är breda, generella frågor om välbefinnande. Item 2 och 3 har också låg item fit, vilket indikerar att de bidrar med relativt lite information. Targeting visar att 2 och 3 ligger nära varandra och nära mitten av distributionen (något under). Vi kommer förmodligen bara kunna behålla ett item av dessa tre, och item 1 verkar lämpligast, följt av item 2.

Items 6, 7 och 8 har starka residualkorrelationer sinsemellan. Fråga 8 ter sig mindre innehållsmässigt relevant, och tas därför bort.

Det är intressant att se hur items 4 och 6-8 ligger klart högst i itemhierarkin.

Item 4 har fortfarande för hög item fit och verkar inte passa in, men vi behåller den ett tag till p.g.a. targeting, och för att se vad som händer när vi tar bort andra items.

Således tar vi bort (pga residualkorrelationer):

  • items 3 och 8
Code
removed.items <- c("mhc3","mhc8")
df2 <- df.omit.na %>% 
  select(!any_of(removed.items))

5 Rasch-analys 3

itemnr item
mhc1 lycka, glädje
mhc2 ett intresse för livet (att livet engagerar)
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc7 att människor i grunden är goda
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIitemfitPCM2(df2, 250, 32, 8)
OutfitMSQ InfitMSQ OutfitZSTD InfitZSTD
mhc1 0.921 0.901 -0.583 -1.371
mhc2 0.816 0.808 -2.185 -2.424
mhc4 1.402 1.285 2.197 2.542
mhc5 1.216 1.147 1.89 1.556
mhc6 1.091 1.038 1.147 0.466
mhc7 1.096 1.055 1.102 0.401
mhc9 0.725 0.738 -3.122 -3.274
mhc10 1.017 0.97 -0.02 -0.239
mhc11 0.826 0.825 -1.515 -2.009
mhc12 0.966 0.952 -0.417 -0.536
mhc13 0.909 0.911 -1.039 -0.855
mhc14 0.704 0.723 -3.024 -3.858
Code
RIpcmPCA(df2)
PCA of Rasch model residuals
Eigenvalues
1.67
1.63
1.32
1.24
1.11
Code
RIresidcorr(df2, cutoff = 0.2)
mhc1 mhc2 mhc4 mhc5 mhc6 mhc7 mhc9 mhc10 mhc11 mhc12 mhc13 mhc14
mhc1
mhc2 0.36
mhc4 -0.16 -0.13
mhc5 -0.04 -0.08 -0.05
mhc6 -0.14 -0.12 0 -0.09
mhc7 -0.12 -0.14 -0.1 -0.1 0.27
mhc9 -0.04 -0.06 -0.19 -0.18 -0.12 -0.11
mhc10 -0.15 -0.13 -0.15 -0.18 -0.11 -0.12 0.01
mhc11 -0.03 -0.12 -0.2 0.07 -0.2 -0.1 -0.04 0
mhc12 -0.19 -0.2 -0.05 -0.2 -0.11 -0.14 -0.11 -0.01 -0.03
mhc13 -0.15 -0.19 -0.07 -0.13 -0.19 -0.2 0.07 -0.1 -0.08 0.05
mhc14 -0.11 0.05 -0.12 -0.21 -0.16 -0.16 0.01 -0.02 -0.11 0 0.03
Note:
Relative cut-off value (highlighted in red) is 0.115, which is 0.2 above the average correlation.
Code
RIloadLoc(df2)

Code
# increase fig-height above as needed, if you have many items
RItargeting(df2)

Code
RIitemHierarchy(df2)

Stora residualkorrelationer kvarstår mellan 1 och 2 samt 6 och 7. Vi tar bort 2 och 7.

Item 4 ser något bättre ut nu, men fortfarande hög item fit. Den får vara kvar ett steg till.

Code
removed.items <- c("mhc2","mhc3","mhc8","mhc7")
df2 <- df.omit.na %>% 
  select(!any_of(removed.items))

6 Rasch-analys 4

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIitemfitPCM2(df2, 250, 32, 8)
OutfitMSQ InfitMSQ OutfitZSTD InfitZSTD
mhc1 0.979 0.956 -0.079 -0.791
mhc4 1.34 1.238 1.867 2.362
mhc5 1.177 1.13 1.479 1.201
mhc6 1.18 1.092 1.547 0.919
mhc9 0.707 0.722 -3.109 -3.28
mhc10 0.969 0.939 -0.553 -0.564
mhc11 0.797 0.802 -2.031 -2.547
mhc12 0.908 0.904 -0.94 -1.207
mhc13 0.838 0.854 -1.742 -1.94
mhc14 0.695 0.717 -2.977 -3.526
Code
RIpcmPCA(df2)
PCA of Rasch model residuals
Eigenvalues
1.50
1.42
1.20
1.17
1.04
Code
RIresidcorr(df2, cutoff = 0.2)
mhc1 mhc4 mhc5 mhc6 mhc9 mhc10 mhc11 mhc12 mhc13 mhc14
mhc1
mhc4 -0.15
mhc5 -0.02 -0.07
mhc6 -0.1 0.01 -0.08
mhc9 -0.02 -0.22 -0.2 -0.1
mhc10 -0.14 -0.19 -0.21 -0.1 -0.01
mhc11 -0.02 -0.23 0.04 -0.19 -0.06 -0.03
mhc12 -0.19 -0.09 -0.24 -0.11 -0.15 -0.05 -0.07
mhc13 -0.15 -0.11 -0.18 -0.19 0.03 -0.15 -0.13 0
mhc14 -0.08 -0.14 -0.22 -0.13 0 -0.04 -0.13 -0.03 -0.01
Note:
Relative cut-off value (highlighted in red) is 0.097, which is 0.2 above the average correlation.
Code
RIloadLoc(df2)

Code
# increase fig-height above as needed, if you have many items
RItargeting(df2)

Code
RIitemHierarchy(df2)

Denna uppsättning items fungerar relativt väl tillsammans. Några items har något låga värden på item fit ZSTD, vilket inte är idealiskt men acceptabelt. Item 4 har något hög item fit, men kompletterar väl innehållsmässigt och sett till targeting där både 4 och 6 sticker ut. Figuren med faktorladdningar på första residualkontrasten visar också att item 4 och 6 avviker något, där item 4 gör det mera än 6. Detta indikerar viss multidimensionalitet rörande frågorna som innehåller “samhället”.

Vi tittar kort på MHC utan dessa två items:

Code
df2 %>% 
  select(!mhc4) %>% 
  select(!mhc6) %>% 
  RIitemfitPCM2(.,250,32,8)
OutfitMSQ InfitMSQ OutfitZSTD InfitZSTD
mhc1 1.022 0.994 0.162 -0.528
mhc5 1.345 1.201 2.673 1.948
mhc9 0.742 0.745 -2.877 -3.123
mhc10 1.017 0.981 0.061 -0.079
mhc11 0.801 0.792 -2.139 -2.26
mhc12 1.001 0.982 0.205 -0.106
mhc13 0.886 0.885 -1.091 -1.355
mhc14 0.743 0.749 -2.928 -3.106
Code
df2 %>% 
  select(!mhc4) %>% 
  select(!mhc6) %>% 
  RItargeting()

Takeffekten blir tydlig.

Vi återgår till att ha med item 4 och 6 och undersöker invarians.

7 DIF-analys

7.1 Kön

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIdifTable(df2, dif.gender)

Item 2 3 Mean location StDev MaxDiff
mhc1 -0.786 -0.817 -0.802 0.022 0.031
mhc4 1.077 1.063 1.070 0.010 0.014
mhc5 -0.541 -0.319 -0.430 0.157 0.222
mhc6 1.657 1.385 1.521 0.193 0.272
mhc9 0.017 -0.255 -0.119 0.192 0.272
mhc10 -0.367 -0.123 -0.245 0.173 0.244
mhc11 -0.843 -0.461 -0.652 0.270 0.382
mhc12 0.011 0.133 0.072 0.087 0.122
mhc13 -0.186 -0.402 -0.294 0.153 0.216
mhc14 -0.038 -0.204 -0.121 0.117 0.165
Code
RIdifFigure(df2, dif.gender)

Code
RIdifFigThresh(df2, dif.gender)

Item 11, varma och tillitsfulla relationer med andra, är närmast gränsvärdet på 0.5 logits, ej problematiskt sammantaget. Det är framför allt den lägsta tröskeln som skiljer sig mellan pojkar och flickor.

7.2 Årskurs

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIdifTable(df2, dif.arskurs)

Item 2 4 5 Mean location StDev MaxDiff
mhc1 -0.878 -0.844 -0.657 -0.793 0.119 0.221
mhc4 1.168 1.005 1.009 1.061 0.093 0.163
mhc5 -0.367 -0.431 -0.499 -0.432 0.066 0.132
mhc6 1.326 1.572 1.630 1.509 0.161 0.304
mhc9 -0.105 -0.100 -0.161 -0.122 0.034 0.060
mhc10 -0.360 -0.240 -0.083 -0.228 0.139 0.276
mhc11 -0.616 -0.612 -0.732 -0.653 0.068 0.119
mhc12 0.149 0.067 -0.002 0.071 0.076 0.151
mhc13 -0.182 -0.287 -0.406 -0.292 0.112 0.223
mhc14 -0.135 -0.129 -0.101 -0.121 0.018 0.034
Code
RIdifFigure(df2, dif.arskurs)

Code
RIdifFigThresh(df2, dif.arskurs)

Node 3 = åk 7, Node 4 = åk 9, Node 5 = Gy 2.

7.3 Kön och årskurs

Vi undersöker även interaktionen mellan kön och årskurs.

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
dfin <- df2

df.tree <- data.frame(matrix(ncol = 0, nrow = nrow(dfin)))
df.tree$difdata <- as.matrix(dfin)
df.tree$dif.gender <- dif.gender
df.tree$dif.arskurs <- dif.arskurs

pctree.out <- pctree(difdata ~ dif.gender + dif.arskurs, data = df.tree)
plot(pctree.out)

Code
cutoff <- 0.5
diffig <- itempar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame() %>%
  mutate(
    `Mean location` = rowMeans(.),
    StDev = rowSds(as.matrix(.))
  ) %>%
  rowwise() %>%
  mutate(MaxDiff = (max(c_across(c(1:(ncol(.) - 2))))) -
    min(c_across(c(1:(ncol(.) - 2))))) %>%
  ungroup() %>%
  mutate(across(where(is.numeric), round, 3)) %>%
  rownames_to_column(var = "Item") %>%
  mutate(Item = names(dfin)) %>%
  relocate(MaxDiff, .after = last_col()) 

  formattable(diffig,
    list(MaxDiff = formatter("span",
      style = ~ style(color = ifelse(MaxDiff < -cutoff,
        "red", ifelse(MaxDiff > cutoff, "red", "black")
      ))
    ),
    formattable::area(col = 2:6) ~ color_tile(RISEprimYellowLight, RISEprimGreen)
    ),
    table.attr = "class=\"table table-striped\" style=\"font-size: 15px; font-family: Lato\""
  )
Item 4 5 6 8 10 11 Mean location StDev MaxDiff
mhc1 -0.826 -0.806 -0.711 -0.951 -0.889 -0.605 -0.798 0.124 0.346
mhc4 1.191 0.989 1.047 1.162 1.032 0.990 1.068 0.088 0.203
mhc5 -0.591 -0.465 -0.595 -0.151 -0.405 -0.420 -0.438 0.163 0.444
mhc6 1.550 1.708 1.761 1.184 1.495 1.551 1.542 0.203 0.577
mhc9 0.007 0.015 0.033 -0.223 -0.233 -0.323 -0.121 0.156 0.356
mhc10 -0.457 -0.399 -0.204 -0.275 -0.090 0.012 -0.235 0.179 0.469
mhc11 -0.823 -0.801 -0.940 -0.418 -0.433 -0.556 -0.662 0.222 0.523
mhc12 0.110 0.005 -0.114 0.185 0.120 0.089 0.066 0.106 0.299
mhc13 -0.104 -0.187 -0.298 -0.294 -0.405 -0.539 -0.305 0.154 0.435
mhc14 -0.058 -0.059 0.022 -0.219 -0.193 -0.199 -0.118 0.099 0.241
Code
pctree.par <- itempar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame()
pctree.par$Item <- names(dfin)
pctree.par$item <- NULL
rownames(pctree.par) <- NULL
pctree.par <- melt(pctree.par, id.vars = "Item")
names(pctree.par) <- c("Item", "Group", "Logits")
pctree.par$Item <- factor(pctree.par$Item, levels = names(dfin))
ggplot(pctree.par, aes(
  x = Item, y = Logits, color = Group,
  group = Group
)) +
  geom_line(linewidth = 1.5, alpha = 0.8) +
  geom_point(size = 2.5)

Items 6 och 11 uppvisar skillnader strax över gränsvärdet. Båda mellan flickor i gy 2 och pojkar i åk 7. För item 6 uppvisar flickorna högre item location än pojkarna, och omvänt för item 11. Det innebär att de förmodligen tar ut DIF-effekten när mätvärden estimeras.

Items 5 och 10 ligger också strax under gränsvärdet, och för item 5 gäller det samma grupper.

7.4 Skolkommun

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIdifTable(df2, dif.skolkommun)

Item 2 3 Mean location StDev MaxDiff
mhc1 -0.835 -0.791 -0.813 0.031 0.044
mhc4 1.150 1.044 1.097 0.075 0.106
mhc5 -0.333 -0.450 -0.391 0.083 0.117
mhc6 1.335 1.531 1.433 0.138 0.196
mhc9 -0.077 -0.132 -0.104 0.039 0.054
mhc10 -0.312 -0.215 -0.264 0.069 0.097
mhc11 -0.620 -0.651 -0.636 0.022 0.031
mhc12 0.071 0.078 0.075 0.005 0.007
mhc13 -0.273 -0.285 -0.279 0.009 0.012
mhc14 -0.105 -0.130 -0.117 0.017 0.025
Code
RIdifFigure(df2, dif.skolkommun)

Code
RIdifFigThresh(df2, dif.skolkommun)

Inga problem.

7.5 Årtal

Code
removed.items <- c("mhc2","mhc3","mhc8","mhc7")

df.difyears <- df %>% 
  mutatertal = factor(inars)) %>% 
  select(starts_with("I1_"),Årtal) %>% 
  na.omit()

dif.years <- df.difyears$Årtal
df.difyears$Årtal <- NULL

names(df.difyears) <- itemlabels$itemnr

for (i in itemlabels$itemnr) {
  df.difyears[[i]] <- recode(df.difyears[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

df.difyears <- df.difyears %>% 
  select(!any_of(removed.items))
itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIdifTable(df.difyears, dif.years)

Item 2 3 Mean location StDev MaxDiff
mhc1 -0.798 -0.967 -0.882 0.119 0.168
mhc4 1.050 1.165 1.108 0.081 0.115
mhc5 -0.418 -0.409 -0.413 0.006 0.009
mhc6 1.478 1.560 1.519 0.058 0.082
mhc9 -0.121 -0.174 -0.148 0.037 0.053
mhc10 -0.230 -0.202 -0.216 0.020 0.028
mhc11 -0.635 -0.644 -0.639 0.006 0.009
mhc12 0.076 0.056 0.066 0.014 0.020
mhc13 -0.281 -0.273 -0.277 0.006 0.008
mhc14 -0.121 -0.113 -0.117 0.006 0.008
Code
RIdifFigure(df.difyears, dif.years)

Code
RIdifFigThresh(df.difyears, dif.years)

Inga problem.

7.6 DIF sammanfattning

Överlag fungerar items stabilt mellan kön, årskurs, kommun och över tid. Interaktionen mellan årskurs och kön visar på skillnader gällande vissa items, men inte i problematiska nivåer sammantaget med antalet items.

8 Reliabilitet

Code
RItif(df.difyears)

9 Item-parametrar

Code
RIitemparams(df.difyears)
Threshold 1 Threshold 2 Threshold 3 Item location
mhc1 -2.18 -0.50 0.96 -0.57
mhc4 0.70 1.58 1.98 1.42
mhc5 -0.66 -0.12 0.48 -0.1
mhc6 0.92 1.98 2.58 1.83
mhc9 -0.89 0.34 1.04 0.16
mhc10 -1.17 0.36 1.10 0.1
mhc11 -1.51 -0.08 0.61 -0.33
mhc12 -0.90 0.89 1.14 0.38
mhc13 -1.02 0.39 0.74 0.03
mhc14 -0.64 0.53 0.70 0.19
Code
# write final item names and descriptions to a file
itemlabels %>% 
  filter(itemnr %in% names(df.difyears)) %>% 
  write_csv("mhcItemnr.csv")

10 Transformeringstabell

Code
RIscoreSE(df.difyears)
Ordinal sum score Logit score Logit std.error
0 -4.000 1.435
1 -2.904 0.890
2 -2.306 0.706
3 -1.890 0.609
4 -1.565 0.547
5 -1.296 0.503
6 -1.065 0.470
7 -0.860 0.445
8 -0.675 0.426
9 -0.506 0.410
10 -0.347 0.398
11 -0.198 0.389
12 -0.054 0.382
14 0.221 0.374
15 0.355 0.372
16 0.489 0.372
17 0.624 0.374
18 0.761 0.378
19 0.901 0.383
20 1.047 0.391
21 1.198 0.400
22 1.359 0.413
23 1.530 0.429
24 1.716 0.449
25 1.922 0.476
26 2.156 0.513
27 2.435 0.568
28 2.788 0.656
29 3.301 0.828
30 4.000 1.165

11 Visualiseringar

Code
# prepare dataframe with all data and variables of interest
removed.items <- c("mhc2","mhc3","mhc8","mhc7")

df.viz <- df %>% 
  mutatertal = factor(inars),
         Årskurs = recode(arskurs,"1='Åk 7';2='Åk 9';3='Gy 2';9=NA;99=NA", as.factor = TRUE),
         Kön = recode(kon,"99=NA;9=NA;2='Flickor';1='Pojkar'", as.factor = T),
         Skolkommun = recode(skolkommun,"1='Enköping';2='Heby';3='Håbo';4='Knivsta';
                             5='Tierp';6='Uppsala';7='Älvkarleby';8='Östhammar'", as.factor = T)
         #across(everything(), ~na_if(., ""))
         ) %>% 
  select(starts_with("I1_"),Årtal,Årskurs,Kön,Skolkommun,A1)

# koda om "Hur mår du rent allmänt?"
df.viz <- df.viz %>% 
  mutate(A1num = recode(A1,"'Mycket dåligt'=0;
                    'Dåligt'=1;
                    'Varken bra eller dåligt'=2;
                    'Bra'=3;
                    'Mycket bra'=4",
                    as.factor = FALSE)
  ) %>% 
  rename_at(vars(starts_with("I1_")), ~ itemlabels$itemnr) %>% 
  select(!any_of(removed.items))
Code
# estimate MHC person locations based on Rasch analysis

# define final set of items
scale.items <- df.viz %>% 
  select(starts_with("mhc")) %>% 
  names()

# create id-variable to re-join data later
df.viz$individID <- seq.int(nrow(df.viz))

# filter out those with fewer than 6 item responses
min.responses <- 6
# create new dataframe based on the filtering
df.omit.na <- df.viz %>% 
  select(starts_with("mhc"),individID) %>%
  filter(length(scale.items)-rowSums(is.na(.[scale.items])) >= min.responses)

# save the vector of ID's for merging dataframes later
idnr <- df.omit.na$individID
# then remove it
df.omit.na$individID <- NULL

# read item threshold locations previously estimated
items <- as.matrix(read_csv("itemParameters.csv"))

# recode raw responses according to analysis
for (i in names(df.omit.na)) {
  df.omit.na[[i]] <- recode(df.omit.na[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}
Code
### This chunk is not run when rendering the HTML report, since theta estimation takes a lot of time.

# load library and estimate person locations/scores
library(catR)
thetaEstScores <- c()
for (i in 1:nrow(df.omit.na)){
  p1 <- as.numeric(as.vector(df.omit.na[i,]))
  ptheta <- thetaEst(items, p1, model = "PCM", method = "WL")
  thetaEstScores <- c(thetaEstScores,ptheta)
}

# insert interval scores to new df
thetas <- as.data.frame(thetaEstScores) %>%  
  mutate(across(where(is.numeric),round,3)) # round to 3 digits

# insert id variable to new df
thetas$individ <- idnr 
names(thetas) <- c("mhcScore","individID") 

# merge to a new dataframe which includes raw responses
df.viz <- merge(df.viz, thetas,
                   by = "individID", all = T)

# write visualization df to file to speed up things later
#write_parquet(df.viz, glue("/Volumes/magnuspjo/RegionUppsala/data/{Sys.Date()}_mhcScored.parquet"))
Code
# read estimated person thetas
df.viz <- read_parquet("/Volumes/magnuspjo/RegionUppsala/data/2023-03-31_mhcScored.parquet")
scale.items <- df.viz %>% 
  select(starts_with("mhc")) %>% 
  select(!mhcScore) %>% 
  names()

11.1 MHC över tid

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Kön, color = Kön, fill = Kön)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-2,3)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde")

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Skolkommun) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Skolkommun, color = Skolkommun, fill = Skolkommun)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-1.5,2)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på skolkommun",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde")

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Skolkommun,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Skolkommun, color = Skolkommun, fill = Skolkommun)) +
  geom_point(size = 2, alpha = 0.8) +
  geom_line(linewidth = 1, alpha = 0.8) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-2,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_wrap(~Kön)

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Skolkommun,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Skolkommun, color = Skolkommun, fill = Skolkommun)) +
  geom_point(size = 2, alpha = 0.8) +
  geom_line(linewidth = 1, alpha = 0.8) +
  scale_y_continuous(limits = c(-0.5,1)) +
  scale_color_manual(values = RISEpalette2) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_wrap(~Kön)

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Skolkommun,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Skolkommun, color = Skolkommun, fill = Skolkommun)) +
  geom_point(size = 2, alpha = 0.8) +
  geom_line(linewidth = 1, alpha = 0.8) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-2,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_grid(Kön~Skolkommun)

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Årskurs) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Årskurs, color = Årskurs, fill = Årskurs)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-1.5,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde")

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Årskurs,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Kön, color = Kön, fill = Kön)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-1.5,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön och årskurs",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_wrap(~ Årskurs)

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  group_by(Årtal,Årskurs,Kön) %>% 
  summarise(mhcMean = mean(mhcScore, na.rm = T),
            mhcSD = sd(mhcScore, na.rm = T)) %>% 
  ggplot(aes(x = Årtal, y = mhcMean, group = Årskurs, color = Årskurs, fill = Årskurs)) +
  geom_point(size = 3) +
  geom_line(linewidth = 1.5) +
  geom_ribbon(aes(ymin = mhcMean-mhcSD, ymax = mhcMean+mhcSD),
              alpha = 0.1, linetype = 0) +
  scale_y_continuous(limits = c(-1.5,2.5)) +
  labs(title = "Mental Health Continuum",
       subtitle = "Uppdelat på kön och årskurs",
       caption = "Skuggat område indikerar +/- en standardavvikelse från medelvärdet") +
  ylab("MHC medelvärde") +
  facet_wrap(~ Kön)

Code
df.viz %>% 
  filter(Årtal %in% c("2019","2021")) %>% 
  ggplot(aes(x = mhcScore, y = Årtal, fill = Årtal)) + # make plot, with area color
  stat_slab(side = "right", show.legend = F,
            scale = 0.6, # defines the height that a slab can reach
            position = position_dodge(width=.6), # distance between elements for dodging
            aes(fill_ramp = after_stat(level), fill=Årtal),
            .width = c(.50,.80,1)) +  # set shading
  # stat_dots(side = "left",scale = 0.9, show.legend = F,
  #           position = position_dodge(width = .9),aes(color = Kommun),
  #           alpha = 0.15) +
  stat_summary(fun.data = "mean_cl_normal",show.legend = F, size = .4,
               position = position_dodge2nudge(x=.05,width = .8)) +
  scale_fill_ramp_discrete(from='black', aesthetics = "fill_ramp") +
  #scale_fill_viridis_d(begin = 0.4) +
  scale_fill_manual(values = RISEpalette0) +
  # styling
  theme(axis.text.x = element_text(size=ax.size, family = "sans"),
        #axis.text.y = element_blank(),
        title = element_text(size=title.size),
  )+
  xlab("Mental Health Continuum") +
  ylab("Fördelning av personer")

12 “Hur mår du rent allmänt?”

Frågeställningen verkar fram till och med 2015 varit “Hur mår du?”, och ändrades 2017 till “Hur mår du rent allmänt?”. Svarsalternativen verkar ha varit samma från 2013 till och med 2021 (det jag har uppgifter om).

Code
# function for Wilson's proportional confidence interval, from:
# https://github.com/rpruim/fastR2/blob/main/R/wilson.ci.R
wilson.ci <- function (x, n = 100, conf.level = 0.95) {
    alpha = 1 - conf.level
    p = (x + 2)/(n + 4)
    zstar <- -qnorm(alpha/2)
    interval <- p + c(-1, 1) * zstar * sqrt(p * (1 - p)/(n+4))
    attr(interval, "conf.level") <- conf.level
    return(interval)
}
Code
df.A1 <- df.viz %>% 
  mutate(A1 = factor(A1, levels = c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra"))) %>% 
  #filter(Kön %in% c("Pojkar","Flickor")) %>% 
  select(Årtal, A1) %>% 
  group_by(Årtal) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )

# with gender grouping
df.A1g <- df.viz %>% 
  mutate(A1 = factor(A1, levels = c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra"))) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  select(Årtal, A1, Kön) %>% 
  group_by(Årtal,Kön) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )
Code
# grouped responses

df.A1grouped <- df.viz %>% 
  mutate(A1 = recode(A1,"'Mycket dåligt'='Mycket dåligt eller dåligt';
                     'Dåligt'='Mycket dåligt eller dåligt';
                     'Varken bra eller dåligt'='Varken bra eller dåligt';
                     'Bra'='Bra eller mycket bra';
                     'Mycket bra'='Bra eller mycket bra'",
                     as.factor = TRUE)
         ) %>% 
  #filter(Kön %in% c("Pojkar","Flickor")) %>% 
  select(Årtal, A1) %>% 
  group_by(Årtal) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )

df.A1groupedSK <- df.viz %>% 
  mutate(A1 = recode(A1,"'Mycket dåligt'='Mycket dåligt eller dåligt';
                     'Dåligt'='Mycket dåligt eller dåligt';
                     'Varken bra eller dåligt'='Varken bra eller dåligt';
                     'Bra'='Bra eller mycket bra';
                     'Mycket bra'='Bra eller mycket bra'",
                     as.factor = TRUE)
         ) %>% 
  #filter(Kön %in% c("Pojkar","Flickor")) %>% 
  filter(!is.na(Skolkommun)) %>% 
  select(Årtal, A1, Skolkommun) %>% 
  group_by(Årtal,Skolkommun) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )

12.0.1 Grupperade svar

Detta är en “kopia” av figuren som Region Uppsala har med i sina rapporter. Där har man slagit samman de två högsta svarskategorierna till en och samma (Bra och Mycket bra).

Code
# get max/min for every year, based on municipalities grouping
yminSK <- df.A1groupedSK %>% 
  filter(Svarsalternativ == "Bra eller mycket bra") %>% 
  select(Procent) %>% 
  group_by(År) %>% 
  summarise(ymin = min(Procent)) %>% 
  pull(ymin)

ymaxSK <- df.A1groupedSK %>% 
  filter(Svarsalternativ == "Bra eller mycket bra") %>% 
  select(Procent) %>% 
  group_by(År) %>% 
  summarise(ymax = max(Procent)) %>% 
  pull(ymax)

årtal <- df.A1grouped %>% 
  distinct(År) %>% 
  mutater = as.numeric(as.character(År))) %>% 
  pull()

df.A1grouped %>% 
  filter(Svarsalternativ == "Bra eller mycket bra") %>% 
  #mutate(procentText = round(Procent,1)) %>% # skriv data med %-tecken
  mutater = as.numeric(as.character(År))) %>% 
  ggplot(aes(x = År, y = Procent, color = RISEprimGreen, fill = RISEprimGreen)) +
    geom_ribbon(aes(ymin = yminSK, ymax = ymaxSK),
              alpha = 0.5, linetype = 0, fill = "grey70") +
  geom_point(size = 12) +
  geom_line(aes(group = 1), linewidth = 2) +
  geom_text(aes(label = round(Procent,1)), color = "white") +
  scale_y_continuous(limits = c(0,100), breaks = c(0,20,40,60,80,100)) +
  scale_x_continuous(breaks = årtal, 
                     minor_breaks = NULL) +
  scale_color_manual(values = RISEprimGreen, guide = "none") +
  labs(title = "Hur mår du rent allmänt?",
       subtitle = "Samtliga respondenter som svarat 'Bra' eller 'Mycket bra'",
       caption = "Skuggat fält indikerar högsta och lägsta medelvärde bland deltagande skolkommuner") +
  ylab("Andel respondenter i procent") +
  theme_minimal() +
  theme_rise() +
  theme(legend.position = "none")

Code
# grouped responses

df.A1groupedG <- df.viz %>% 
  mutate(A1 = recode(A1,"'Mycket dåligt'='Mycket dåligt eller dåligt';
                     'Dåligt'='Mycket dåligt eller dåligt';
                     'Varken bra eller dåligt'='Varken bra eller dåligt';
                     'Bra'='Bra eller mycket bra';
                     'Mycket bra'='Bra eller mycket bra'",
                     as.factor = TRUE)
         ) %>% 
  filter(Kön %in% c("Pojkar","Flickor")) %>% 
  select(Årtal, Kön, A1) %>% 
  group_by(Årtal, Kön) %>% 
  pivot_longer(A1) %>% 
  count(name, value) %>% # räkna hur många individer i varje svarskategori
  mutate(percent = (100 * n / sum(n))) %>% # räkna fram procent för varje svarskategori, behövs kanske inte men är smidigt när vi gör figuren senare
  mutate(proportion = (n / sum(n))) %>% 
  #mutate(wCI = wilson.ci(n, sum(n)))
  mutate(sem = sqrt(proportion * (1 - proportion) / sum(n))) %>% # räkna ut standard error of measurement
  mutate(
    lower.95ci = proportion - sem * 1.96, # räkna fram nedre och högre gränsvärden för 95% CI
    upper.95ci = proportion + sem * 1.96) %>% 
  mutate(across(where(is.numeric), round, 3)) %>% 
  rename(
    Svarsalternativ = value, # byt namn på variabler inför skapande av figur.
    "Antal svar" = n,
    Procent = percent,
    År = Årtal
  )
Code
df.A1groupedG %>% 
  filter(Svarsalternativ == "Bra eller mycket bra") %>% 
  #mutate(procentText = round(Procent,1)) %>% # skriv data med %-tecken
  ggplot(aes(x = År, y = Procent, group = Kön, color = Kön, fill = Kön)) +
  geom_point(size = 12) +
  geom_line(linewidth = 2) +
  geom_text(aes(label = round(Procent,1)), color = "white") +
  scale_y_continuous(limits = c(0,100), breaks = c(0,20,40,60,80,100)) +
  scale_color_manual(values = RISEpalette1[c(1,5)])  +
    labs(title = "Hur mår du rent allmänt?",
       subtitle = "Flickor och pojkar i åk 7, 9 och gy 2 som svarat 'Bra' eller 'Mycket bra'") +
  ylab("Andel respondenter i procent") +
  theme_minimal() +
  theme_rise() +
  theme(legend.background = element_rect(color = "lightgrey"))

12.0.2 Uppdelade svarskategorier

Code
df.A1 %>% 
  filter(Svarsalternativ %in% c("Bra","Mycket bra")) %>% 
  #mutate(procentText = round(Procent,1)) %>% # skriv data med %-tecken
  ggplot(aes(x = År, y = Procent, color = Svarsalternativ, fill = Svarsalternativ)) +
  geom_point(size = 12) +
  geom_line(aes(group = Svarsalternativ), linewidth = 2) +
  geom_text(aes(label = round(Procent,1)), color = "white") +
  scale_y_continuous(limits = c(0,80), breaks = c(0,20,40,60,80)) +
  scale_color_manual(values = RISEpalette1) +
  labs(title = "Samtliga respondenter") +
  theme_minimal() +
  theme_rise() +
  theme(legend.background = element_rect(color = "lightgrey"))

Code
library(ggiraph)
df.A1g %>% 
  filter(Svarsalternativ %in% c("Bra","Mycket bra")) %>% 
  #mutate(procentText = round(Procent,1)) %>% # skriv data med %-tecken
  ggplot(aes(x = År, y = Procent, color = Svarsalternativ, fill = Svarsalternativ)) +
  geom_point(aes(tooltip = round(Procent,1)),
                         size = 4) +
  geom_line(aes(group = Svarsalternativ), linewidth = 1.5) +
  #geom_text(aes(label = round(Procent,1)), color = "white") +
  scale_y_continuous(limits = c(0,60), breaks = c(0,20,40,60)) +
  scale_x_discrete(guide = guide_axis(n.dodge = 2)) +
  scale_color_manual(values = RISEpalette1) +
  facet_wrap(~Kön) +
  theme_minimal() +
  theme_rise() +
  theme(strip.background = element_rect(color = "lightgrey"),
        legend.background = element_rect(color = "lightgrey")
        )

Code
#girafe(ggobj = MHCgroupedGfig)

12.0.3 Senaste tre åren, alla svarskategorier

Code
df.A1 %>%
  filter(År %in% c("2017","2019","2021")) %>% 
  filter(!is.na(Svarsalternativ)) %>% 
  mutate(Procent = round(Procent, 1)) %>% # avrunda till en decimal
  mutate(procentText = sprintf("%1.1f%%", Procent)) %>% # skriv data med %-tecken
  ggplot(aes(x = Svarsalternativ, y = Procent, group = År, fill = År)) + # gör en figur grupperad och kolorerad utifrån år
  geom_bar(position = position_dodge(), stat = "identity") + # stapeldiagram, där staplarna ligger intill varandra
  geom_errorbar(aes(ymin = lower.95ci * 100, ymax = upper.95ci * 100), # visa 95% CI
    width = .2,
    position = position_dodge(.9)
  ) +
  geom_text(aes(label = .data$"Antal svar"), # visa text
    position = position_dodge(width = 1),
    hjust = -0.1, vjust = -0.9
  ) +
  # geom_text(aes(label = paste0(procentText," +/- ",sprintf("%1.1f%%",round(sem*1.96*100,2))), y = 7, angle = 90),
  geom_text(aes(label = procentText, y = 1, angle = 0),
    position = position_dodge(width = 1),
    hjust = 0.5,
    color = "white"
  ) +
  scale_fill_viridis_d(begin = 0.3, end = 0.9, option = 7) + # sätt kulörskala
  theme(
    legend.position = "right",
    plot.caption = element_text(face = "italic", size = 8)
  ) +
  labs(
    title = "Hur mår du rent allmänt?",
    caption = "Siffrorna ovanför staplarna anger antalet respondenter i varje svarskategori.\n Svarta vertikala streck visar 95% konfidensintervall."
  )

12.0.4 Alla år, alla svarskategorier

Code
df.A1g %>% 
  filter(!is.na(Svarsalternativ)) %>% 
  ggplot(aes(x = År, y = Procent, color = Svarsalternativ, fill = Svarsalternativ)) +
  geom_point(aes(tooltip = round(Procent,1)),
                         size = 4) +
  geom_line(aes(group = Svarsalternativ), linewidth = 1.5) +
  scale_y_continuous(limits = c(0,60), breaks = c(0,20,40,60)) +
  scale_x_discrete(guide = guide_axis(n.dodge = 2)) + 
  scale_color_manual(values = rev(c("#5C758B","#009CA6", "#F5A127","#B94F70", "#EC5D4F"))) +
  facet_wrap(~Kön) +
  labs(title = "Hur mår du rent allmänt?") +
  theme_minimal() +
  theme_rise() +
  theme(strip.background = element_rect(color = "lightgrey"),
        legend.background = element_rect(color = "lightgrey")
        )

Code
#girafe(ggobj = MHCfigG)

12.1 Jämförelse enstaka fråga och MHC

Code
df.viz %>% 
  filter(!is.na(A1)) %>% 
  mutate(A1 = factor(A1, levels = c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra"))) %>% 
  ggplot(aes(x = A1, y = mhcScore)) +
  geom_violin(aes(fill = A1)) +
  geom_boxplot(width = .3, outlier.shape = NA, alpha = 0.6, notch = TRUE) +
  xlab("Svarskategorier") +
  ylab("Indexvärde MHC") +
  # geom_jitter(shape=16, position=position_jitter(0.2)) +
  # geom_point(data=errbar_lims, aes(x=q11, y=mean), size=3) + # this (and the sectoin below) requires data and aes to be defined only in geom_violin, for unknown reasons
  # geom_errorbar(data=errbar_lims, aes(x=q11, ymax=upper,
  #                   ymin=lower), stat='identity', width=.1) +
  # geom_crossbar(stat="summary", fun.y=mean, fun.ymax=mean, fun.ymin=mean, fatten=5, width=.5) +
  # geom_point(color="black", size=1, position = position_jitter(w=0.1)) +
  scale_fill_manual(values = rev(c("#5C758B","#009CA6", "#F5A127","#B94F70", "#EC5D4F"))) +
  labs(title = "Hur mår du rent allmänt?",
       subtitle = "Enstaka fråga jämfört med indexvärde från MHC",
       caption = "MHC = Mental Health Continuum") +
  theme(
    legend.position = "none",
    text = element_text(family = "sans")
  ) +
  coord_flip() +
  theme_minimal() +
  theme_rise() +
  theme(strip.background = element_rect(color = "lightgrey"),
        legend.background = element_rect(color = "lightgrey")
        )

Code
# get mode values for A1 categories on each mhc item, and calculate corresponding person score

Mode <- function(x) {
  ux <- unique(x)
  ux[which.max(tabulate(match(x, ux)))]
}

# recode raw responses according to analysis
df.vizRecoded <- df.viz

for (i in scale.items) {
  df.vizRecoded[[i]] <- recode(df.vizRecoded[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

#create data frame with 0 rows and 8 columns
psf.modes <- data.frame(matrix(ncol = length(scale.items), nrow = 5))
names(psf.modes) <- scale.items
mydå <- c()
<- c()
vbd <- c()
bra <- c()
mybra <- c()
# get the mode value from each risk group for each item
for (i in scale.items){
  mydå <- Mode(df.vizRecoded %>% filter(A1 == "Mycket dåligt") %>% select(i) %>% na.omit() %>% pull())
<- Mode(df.vizRecoded %>% filter(A1 == "Dåligt") %>% select(i) %>% na.omit() %>% pull())
  vbd <- Mode(df.vizRecoded %>% filter(A1 == "Varken bra eller dåligt") %>% select(i) %>% na.omit() %>% pull())
  bra <- Mode(df.vizRecoded %>% filter(A1 == "Bra") %>% select(i) %>% na.omit() %>% pull())
  mybra <- Mode(df.vizRecoded %>% filter(A1 == "Mycket bra") %>% select(i) %>% na.omit() %>% pull())
  psf.modes[[i]] <- rbind(mydå,då,vbd,bra,mybra)
}

# transform to dataframe with numeric variables for later extraction as vectors
psf.modes<- psf.modes %>% 
  t() %>% 
  as.data.frame()

# read item paramters for thetaEst
items <- as.matrix(read_csv("itemParameters.csv"))

12.2 MHC score baserat på typvärden utifrån single-item svarskategorier

Code
avg1 <- thetaEst(items, psf.modes$V1, model = "PCM", method = "WL")
sem1 <- semTheta(thEst = avg1, it = items, x = psf.modes$V1, model = "PCM", method = "WL")
avg2 <- thetaEst(items, psf.modes$V2, model = "PCM", method = "WL")
sem2 <- semTheta(thEst = avg2, it = items, x = psf.modes$V2, model = "PCM", method = "WL")
avg3 <- thetaEst(items, psf.modes$V3, model = "PCM", method = "WL")
sem3 <- semTheta(thEst = avg3, it = items, x = psf.modes$V3, model = "PCM", method = "WL")
avg4 <- thetaEst(items, psf.modes$V4, model = "PCM", method = "WL")
sem4 <- semTheta(thEst = avg4, it = items, x = psf.modes$V4, model = "PCM", method = "WL")
avg5 <- thetaEst(items, psf.modes$V5, model = "PCM", method = "WL")
sem5 <- semTheta(thEst = avg5, it = items, x = psf.modes$V5, model = "PCM", method = "WL")

I nedanstående figur har vi orangea streckade vertikala linjer som indikerar MHC score estimerat utifrån typvärden på samtliga items i MHC för de fem svarskategorierna.

Code
df.viz %>%
  filter(Årtal %in% c("2019", "2021")) %>%
  ggplot(aes(x = mhcScore, y = Årtal, fill = Årtal)) + # make plot, with area color
  stat_slab(
    side = "right", show.legend = F,
    scale = 0.6, # defines the height that a slab can reach
    position = position_dodge(width = .6), # distance between elements for dodging
    aes(fill_ramp = after_stat(level), fill = Årtal),
    .width = c(.50, .75, 1)
  ) + # set shading
  # stat_dots(side = "left",scale = 0.9, show.legend = F,
  #           position = position_dodge(width = .9),aes(color = Kommun),
  #           alpha = 0.15) +
  stat_summary(fun.data = "mean_cl_normal",show.legend = F, size = .4,
               position = position_dodge2nudge(x=.05,width = .8)) +
  geom_vline(xintercept = avg1, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg1-sem1, xmax = avg1+sem1, alpha = .1) +
  annotate("text", label = "Mycket dåligt", x = avg1, y = 1.5, angle = 90, size = 3) +
  geom_vline(xintercept = avg2, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg2-sem2, xmax = avg2+sem2, alpha = .1) +
  annotate("text", label = "Dåligt", x = avg2, y = 1.5, angle = 90, size = 3) +
  geom_vline(xintercept = avg3, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg3-sem3, xmax = avg3+sem3, alpha = .1) +
  annotate("text", label = "Varken bra eller dåligt", x = avg3, y = 1.5, angle = 90, size = 3) +
  geom_vline(xintercept = avg4, color = "orange", linetype = 2) +
  annotate("text", label = "Bra", x = avg4, y = 1.5, angle = 90, size = 3) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg4-sem4, xmax = avg4+sem4, alpha = .1) +
  geom_vline(xintercept = avg5, color = "orange", linetype = 2) +
  annotate("text", label = "Mycket bra", x = avg5, y = 1.5, angle = 90, size = 3) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg5-sem5, xmax = avg5+sem5, alpha = .1) +
  scale_fill_ramp_discrete(from = "black", aesthetics = "fill_ramp") +
  # scale_fill_viridis_d(begin = 0.4) +
  scale_fill_manual(values = RISEpalette0) +
  # styling
  theme(
    axis.text.x = element_text(size = ax.size, family = "sans"),
    # axis.text.y = element_blank(),
    title = element_text(size = title.size),
  ) +
  xlab("Mental Health Continuum") +
  ylab("Fördelning av personer") +
    theme_minimal() +
  theme_rise() +
  theme(strip.background = element_rect(color = "lightgrey"),
        legend.background = element_rect(color = "lightgrey")
        )

Code
# "Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra"

13 Rasch-analys med single-item

Code
# get item parameters for single-item

df.extra <- df.vizRecoded %>%
  select(starts_with("mhc"),A1num) %>%
  select(!mhcScore) %>%
  na.omit()
Code
RIitemfitPCM2(df.extra, 250, 32, 8)
OutfitMSQ InfitMSQ OutfitZSTD InfitZSTD
mhc1 0.879 0.885 -1.404 -1.292
mhc4 1.34 1.239 2.038 2.389
mhc5 1.117 1.097 0.903 1.095
mhc6 1.108 1.065 0.737 0.892
mhc9 0.705 0.729 -3.13 -3.592
mhc10 0.921 0.913 -0.752 -1.179
mhc11 0.791 0.798 -1.83 -2.449
mhc12 0.935 0.922 -1.182 -0.964
mhc13 0.863 0.869 -1.568 -1.835
mhc14 0.664 0.698 -3.339 -4.078
A1num 1.193 1.163 1.788 1.491
Code
RIpcmPCA(df.extra)
PCA of Rasch model residuals
Eigenvalues
1.58
1.44
1.31
1.17
1.06
Code
RIresidcorr(df.extra, cutoff = 0.2)
mhc1 mhc4 mhc5 mhc6 mhc9 mhc10 mhc11 mhc12 mhc13 mhc14 A1num
mhc1
mhc4 -0.15
mhc5 -0.03 -0.04
mhc6 -0.1 0.03 -0.07
mhc9 -0.06 -0.19 -0.21 -0.09
mhc10 -0.16 -0.15 -0.18 -0.09 -0.03
mhc11 -0.02 -0.21 0.06 -0.15 -0.06 -0.01
mhc12 -0.2 -0.06 -0.2 -0.1 -0.11 -0.01 -0.04
mhc13 -0.17 -0.07 -0.15 -0.18 0.06 -0.14 -0.1 0.02
mhc14 -0.1 -0.14 -0.22 -0.12 -0.01 -0.03 -0.13 0.01 0.01
A1num 0.17 -0.18 -0.12 -0.08 -0.03 -0.12 -0.16 -0.26 -0.19 -0.03
Note:
Relative cut-off value (highlighted in red) is 0.108, which is 0.2 above the average correlation.
Code
RIloadLoc(df.extra)

Code
plot(mirt.rasch, type="trace")

Code
# increase fig-height above as needed, if you have many items
RItargeting(df.extra)

Code
RIitemHierarchy(df.extra)

Code
RItif(df.extra)

13.1 Item-parametrar

Code
RIitemparams(df.extra, "itemParamsExtra.csv")
Threshold 1 Threshold 2 Threshold 3 Threshold 4 Item location
mhc1 -1.79 -0.28 1.16 NA -0.31
mhc4 0.92 1.80 2.12 NA 1.61
mhc5 -0.38 0.08 0.68 NA 0.13
mhc6 1.13 2.19 2.66 NA 1.99
mhc9 -0.61 0.55 1.22 NA 0.38
mhc10 -0.88 0.56 1.28 NA 0.32
mhc11 -1.20 0.12 0.81 NA -0.09
mhc12 -0.63 1.08 1.33 NA 0.59
mhc13 -0.73 0.59 0.94 NA 0.26
mhc14 -0.38 0.72 0.89 NA 0.41
A1num -2.56 -1.60 -0.50 1.86 -0.7

A1num (“Hur mår du rent allmänt?”) har location -0.70, att jämföra med respondenternas medelvärde på 0.55.

Code
barplot(table(df.extra$A1num), col = "#8dc8c7", main = "Hur mår du rent allmänt?",
      ylab = "Antal svar")

13.2 Jämförelse typvärdebaserat och itemtrösklar

I nedanstående figur har vi fortfarande orangea streckade vertikala linjer som indikerar MHC score estimerat utifrån typvärden på samtliga items i MHC för de fem svarskategorierna. Som tillägg finns nu röda linjer som indikerar var svarströsklarna ligger. Det vore kanske mera pedagogiskt att visa på högsta sannolikhet för varje svarskategori i stället, men det får bli en framtida utvecklingsmöjlighet.

Code
# get item threshold locations for item A1
itempse <- read.csv("itemParamsExtra.csv") %>% 
  na.omit() %>% 
  t() %>% 
  as.data.frame() %>% 
  pull('11')

df.viz %>%
  filter(Årtal %in% c("2019", "2021")) %>%
  ggplot(aes(x = mhcScore, y = Årtal, fill = Årtal)) + # make plot, with area color
  stat_slab(
    side = "right", show.legend = F,
    scale = 0.6, # defines the height that a slab can reach
    position = position_dodge(width = .6), # distance between elements for dodging
    aes(fill_ramp = after_stat(level), fill = Årtal),
    .width = c(.50, .80, 1)
  ) + # set shading
  # stat_dots(side = "left",scale = 0.9, show.legend = F,
  #           position = position_dodge(width = .9),aes(color = Kommun),
  #           alpha = 0.15) +
  # stat_summary(fun.data = "mean_cl_normal",show.legend = F, size = .4,
  #             position = position_dodge2nudge(x=.05,width = .8)) +
  geom_vline(xintercept = avg1, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg1-sem1, xmax = avg1+sem1, alpha = .1) +
  geom_vline(xintercept = avg2, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg2-sem2, xmax = avg2+sem2, alpha = .1) +
  geom_vline(xintercept = avg3, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg3-sem3, xmax = avg3+sem3, alpha = .1) +
  geom_vline(xintercept = avg4, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg4-sem4, xmax = avg4+sem4, alpha = .1) +
  geom_vline(xintercept = avg5, color = "orange", linetype = 2) +
  annotate("rect", ymin = 0, ymax = Inf, xmin = avg5-sem5, xmax = avg5+sem5, alpha = .1) +
  geom_vline(xintercept = itempse[1], color = "red", linetype = 5) +
  geom_vline(xintercept = itempse[2], color = "red", linetype = 5) +
  geom_vline(xintercept = itempse[3], color = "red", linetype = 5) +
  geom_vline(xintercept = itempse[4], color = "red", linetype = 5) +
  scale_fill_ramp_discrete(from = "black", aesthetics = "fill_ramp") +
  # scale_fill_viridis_d(begin = 0.4) +
  scale_fill_manual(values = RISEpalette0) +
  # styling
  theme(
    axis.text.x = element_text(size = ax.size, family = "sans"),
    # axis.text.y = element_blank(),
    title = element_text(size = title.size),
  ) +
  xlab("Mental Health Continuum") +
  ylab("Fördelning av personer")

Code
df.erm <- PCM(df.extra)
plotICC(df.erm, item.subset = "A1num", legpos = "topleft")

14 DIF-analys för A1

Vi vill säkerställa att A1, “Hur mår du rent allmänt?” fungerar lika för alla demografiska grupper som svarar på frågan.

Code
removed.items <- c("mhc2","mhc3","mhc8","mhc7")

df.omit.na <- df %>%
  filter(inars %in% c(2019)) %>%
  mutaterskurs = recode(arskurs,"1='Åk 7';2='Åk 9';3='Gy 2';9=NA;99=NA", as.factor = TRUE),
         Kön = recode(kon,"99=NA;9=NA;2='Flickor';1='Pojkar'", as.factor = T),
         Skolkommun = recode(skolkommun,"1='Enköping';2='Heby';3='Håbo';4='Knivsta';
                             5='Tierp';6='Uppsala';7='Älvkarleby';8='Östhammar'", as.factor = T)
         #across(everything(), ~na_if(., ""))
         ) %>%
  select(starts_with("I1_"),Årskurs,Kön,Skolkommun,A1num) %>%
  na.omit()

# create variables for analysis of Differential Item Functioning
dif.arskurs <- df.omit.na$Årskurs
dif.gender <- df.omit.na$Kön
dif.skolkommun <- df.omit.na$Skolkommun

df.omit.na$Årskurs <- NULL
df.omit.na$Kön <- NULL
df.omit.na$Skolkommun <- NULL

names(df.omit.na) <- c(itemlabels$itemnr,"A1num")

for (i in itemlabels$itemnr) {
  df.omit.na[[i]] <- recode(df.omit.na[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

df.omit.na <- df.omit.na %>% 
  select(!any_of(removed.items))

14.1 Kön

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIdifTable(df.omit.na, dif.gender)

Item 2 3 Mean location StDev MaxDiff
mhc1 -0.676 -0.636 -0.656 0.028 0.039
mhc4 1.153 1.155 1.154 0.001 0.001
mhc5 -0.445 -0.194 -0.320 0.177 0.251
mhc6 1.709 1.466 1.587 0.171 0.242
mhc9 0.106 -0.125 -0.010 0.163 0.231
mhc10 -0.271 0.008 -0.132 0.197 0.279
mhc11 -0.733 -0.317 -0.525 0.294 0.415
mhc12 0.102 0.257 0.179 0.109 0.155
mhc13 -0.095 -0.262 -0.178 0.118 0.167
mhc14 0.051 -0.078 -0.014 0.091 0.129
A1num -0.900 -1.273 -1.086 0.263 0.372
Code
RIdifFigure(df.omit.na, dif.gender)

Code
RIdifFigThresh(df.omit.na, dif.gender)

Något högt värde för A1num, men ej över 0.5.

14.2 Årskurs

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIdifTable(df.omit.na, dif.arskurs)

Item 2 4 5 Mean location StDev MaxDiff
mhc1 -0.705 -0.704 -0.535 -0.648 0.098 0.170
mhc4 1.248 1.087 1.101 1.145 0.089 0.161
mhc5 -0.244 -0.329 -0.389 -0.321 0.073 0.145
mhc6 1.400 1.638 1.695 1.578 0.156 0.295
mhc9 0.014 -0.002 -0.054 -0.014 0.036 0.068
mhc10 -0.226 -0.137 0.024 -0.113 0.127 0.250
mhc11 -0.470 -0.496 -0.607 -0.524 0.073 0.137
mhc12 0.266 0.164 0.107 0.179 0.080 0.158
mhc13 -0.058 -0.187 -0.292 -0.179 0.117 0.234
mhc14 -0.015 -0.032 0.003 -0.015 0.017 0.034
A1num -1.211 -1.002 -1.053 -1.089 0.109 0.209
Code
RIdifFigure(df.omit.na, dif.arskurs)

Code
RIdifFigThresh(df.omit.na, dif.arskurs)

Inga problem.

14.3 Kön och årskurs

Vi undersöker även interaktionen mellan kön och årskurs.

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
dfin <- df.omit.na

df.tree <- data.frame(matrix(ncol = 0, nrow = nrow(dfin)))
df.tree$difdata <- as.matrix(dfin)
df.tree$dif.gender <- dif.gender
df.tree$dif.arskurs <- dif.arskurs

pctree.out <- pctree(difdata ~ dif.gender + dif.arskurs, data = df.tree)
plot(pctree.out)

Code
cutoff <- 0.5
diffig <- itempar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame() %>%
  mutate(
    `Mean location` = rowMeans(.),
    StDev = rowSds(as.matrix(.))
  ) %>%
  rowwise() %>%
  mutate(MaxDiff = (max(c_across(c(1:(ncol(.) - 2))))) -
    min(c_across(c(1:(ncol(.) - 2))))) %>%
  ungroup() %>%
  mutate(across(where(is.numeric), round, 3)) %>%
  rownames_to_column(var = "Item") %>%
  mutate(Item = names(dfin)) %>%
  relocate(MaxDiff, .after = last_col())

  formattable(diffig,
    list(MaxDiff = formatter("span",
      style = ~ style(color = ifelse(MaxDiff < -cutoff,
        "red", ifelse(MaxDiff > cutoff, "red", "black")
      ))
    ),
    formattable::area(col = 2:7) ~ color_tile(RISEprimYellowLight, RISEprimGreen)
    ),
    table.attr = "class=\"table table-striped\" style=\"font-size: 15px; font-family: Lato\""
  )
Item 3 5 6 8 10 11 Mean location StDev MaxDiff
mhc1 -0.694 -0.713 -0.604 -0.723 -0.699 -0.476 -0.651 0.096 0.247
mhc4 1.263 1.055 1.149 1.263 1.131 1.069 1.155 0.091 0.208
mhc5 -0.483 -0.380 -0.492 -0.005 -0.282 -0.310 -0.325 0.179 0.488
mhc6 1.606 1.741 1.838 1.284 1.587 1.603 1.610 0.187 0.554
mhc9 0.103 0.091 0.133 -0.069 -0.107 -0.211 -0.010 0.139 0.344
mhc10 -0.348 -0.314 -0.104 -0.108 0.031 0.121 -0.120 0.185 0.469
mhc11 -0.700 -0.706 -0.826 -0.242 -0.301 -0.429 -0.534 0.242 0.584
mhc12 0.203 0.085 -0.009 0.334 0.236 0.196 0.174 0.120 0.344
mhc13 -0.005 -0.111 -0.198 -0.130 -0.275 -0.410 -0.188 0.141 0.405
mhc14 0.038 0.021 0.118 -0.063 -0.077 -0.092 -0.009 0.082 0.210
A1num -0.983 -0.769 -1.004 -1.541 -1.244 -1.063 -1.101 0.264 0.772
Code
pctree.par <- itempar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame()
pctree.par$Item <- names(dfin)
pctree.par$item <- NULL
rownames(pctree.par) <- NULL
pctree.par <- melt(pctree.par, id.vars = "Item")
names(pctree.par) <- c("Item", "Group", "Logits")
pctree.par$Item <- factor(pctree.par$Item, levels = names(dfin))
ggplot(pctree.par, aes(
  x = Item, y = Logits, color = Group,
  group = Group
)) +
  geom_line(linewidth = 1.5, alpha = 0.8) +
  geom_point(size = 2.5)

Code
nodes <- c("Flickor Åk 7","Flickor Åk 9","Flickor Gy 2","Pojkar Åk 7","Pojkar Åk 9","Pojkar Gy 2")

pctree.par %>% 
  filter(Item == "A1num") %>% 
  ggplot(aes(x = Group, y = Logits)) +
  geom_line(linewidth = 1.3, alpha = 0.8, group = 1, color = RISEprimGreen) +
  geom_point(size = 3, color = RISEprimGreen) +
  geom_text_repel(aes(label = round(Logits,2))) +
  geom_hline(aes(yintercept = pull(diffig[10,8])), 
             color = RISEcompPurple, linetype = 2) +
  scale_x_discrete(labels = nodes) +
  labs(title = "A1 - Hur mår du rent allmänt?")

Code
unidif <- threshpar(pctree.out) %>%
  as.data.frame() %>%
  t() %>%
  as.data.frame() %>%
  rownames_to_column("Threshh") %>%
  pivot_longer(where(is.numeric)) %>%
  separate(Threshh,
    c("Item", "Threshold"),
    sep = "-"
  ) %>%
  separate(Item,
    c(NA, "Item"),
    sep = "ata"
  ) %>%
  dplyr::rename(
    `DIF node` = name,
    Location = value
  ) %>%
  mutate(`DIF node` = as.numeric(`DIF node`)) %>%
  mutate(Threshold = dplyr::recode(Threshold,
    C1 = "T1",
    C2 = "T2", C3 = "T3", C4 = "T4", C5 = "T5",
    C6 = "T6", C7 = "T7", C8 = "T8", C9 = "T9",
    C10 = "T10"
  )) %>%
  mutate(Item = factor(Item,
    levels = names(dfin)
  ))
ggplot(unidif, (aes(
  x = factor(`DIF node`), y = Location,
  group = Threshold, color = Threshold
))) +
  geom_line() +
  geom_point() +
  xlab("DIF node") +
  facet_wrap(~Item)

Code
unidif %>% 
  filter(`DIF node` %in% c(3,5,6,8)) %>% 
  filter(Item == "A1num") %>% 
  mutate(meanLocation = mean(Location), .by = `DIF node`) %>% 
  mutate(`DIF node` = car::recode(`DIF node`,"3='Flickor åk 7';5='Flickor åk 9';6='Flickor Gy 2';8='Pojkar åk 7'")
         ) %>% 
ggplot((aes(
  x = `DIF node`, y = Location,
  group = Threshold, color = Threshold
))) +
  geom_line(linewidth = 1.5) +
  geom_point(size = 4) +
  geom_point(aes(y = meanLocation), size = 4, shape = 18, 
        color = "black") +
  geom_text(aes(y = meanLocation-0.2, label = round(meanLocation,2)),
            color = "black") +
  xlab("DIF node")

Det är stor skillnad mellan Flickor åk 9 och Pojkar åk 7 på den övergripande frågan, vilket framgår tydligast under fliken “Figur” ovan.

14.4 Skolkommun

itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIdifTable(df.omit.na, dif.skolkommun)

Item 2 3 Mean location StDev MaxDiff
mhc1 -0.683 -0.648 -0.665 0.025 0.035
mhc4 1.221 1.132 1.176 0.062 0.088
mhc5 -0.226 -0.337 -0.282 0.078 0.110
mhc6 1.408 1.598 1.503 0.134 0.190
mhc9 0.023 -0.022 0.001 0.031 0.044
mhc10 -0.200 -0.101 -0.150 0.070 0.099
mhc11 -0.496 -0.520 -0.508 0.017 0.025
mhc12 0.170 0.189 0.179 0.014 0.019
mhc13 -0.172 -0.169 -0.170 0.002 0.003
mhc14 -0.009 -0.020 -0.014 0.007 0.010
A1num -1.035 -1.103 -1.069 0.048 0.068
Code
RIdifFigure(df.omit.na, dif.skolkommun)

Code
RIdifFigThresh(df.omit.na, dif.skolkommun)

Inga problem.

14.5 Årtal

Code
df.difyears <- df %>% 
  mutatertal = factor(inars)) %>% 
  select(starts_with("I1_"),A1num,Årtal,kon_txt) %>% 
  na.omit()

dif.years <- df.difyears$Årtal
df.difyears$Årtal <- NULL
dif.genderyears <- factor(df.difyears$kon_txt)
df.difyears$kon_txt <- NULL

names(df.difyears) <- c(itemlabels$itemnr,"A1num")

for (i in itemlabels$itemnr) {
  df.difyears[[i]] <- recode(df.difyears[[i]],"1=0;2=1;3=1;4=2;5=3",
                    as.factor = FALSE)
}

df.difyears <- df.difyears %>% 
  select(!any_of(removed.items))
itemnr item
mhc1 lycka, glädje
mhc4 att du har något viktigt att bidra med till samhället
mhc5 att du tillhör en gemenskap
mhc6 att vårt samhälle håller på att bli en bättre plats
mhc9 att du gillar det mesta av din personlighet
mhc10 att du är bra på att ta ansvar för ditt dagliga liv
mhc11 att du har varma och tillitsfulla relationer med andra
mhc12 att du upplevt saker som utmanat dig och fått dig att växa som person
mhc13 att du har självförtroende att ha dina egna tankar och åsikter och att du vågar uttrycka dem
mhc14 att du är på väg någonstans i livet och livet har en mening
Code
RIdifTable(df.difyears, dif.years)

Item 2 3 Mean location StDev MaxDiff
mhc1 -0.647 -0.796 -0.722 0.105 0.149
mhc4 1.131 1.258 1.194 0.090 0.127
mhc5 -0.307 -0.290 -0.299 0.012 0.016
mhc6 1.540 1.632 1.586 0.065 0.092
mhc9 -0.015 -0.056 -0.035 0.029 0.041
mhc10 -0.117 -0.081 -0.099 0.025 0.036
mhc11 -0.505 -0.509 -0.507 0.003 0.004
mhc12 0.182 0.170 0.176 0.008 0.011
mhc13 -0.169 -0.152 -0.161 0.012 0.017
mhc14 -0.016 0.002 -0.007 0.012 0.018
A1num -1.077 -1.177 -1.127 0.071 0.100
Code
RIdifFigure(df.difyears, dif.years)

Code
RIdifFigThresh(df.difyears, dif.years)

Inga problem.

14.6 DIF “Hur mår du rent allmänt?”

Eftersom frågan uppvisade ganska stor skillnad mellan pojkar åk 7 och flickor gy 2 gör vi ett exempel utifrån dessa grupper för att visa vad skillnaden består i och hur den kan visualiseras.

Vi gör först separata items av A1num för de två subgrupperna.

Code
df.difex <- df.omit.na %>% 
  select(!any_of(removed.items)) %>% 
  cbind(.,dif.arskurs) %>% 
  cbind(.,dif.gender) %>% 
  mutate(A1p7 = case_when(dif.arskurs == "Åk 7" & dif.gender == "Pojkar" ~ A1num,
                          .default = NA)) %>% 
  mutate(A1f2 = case_when(dif.arskurs == "Gy 2" & dif.gender == "Flickor" ~ A1num,
                          .default = NA)) %>% 
  select(!dif.gender) %>% 
  select(!dif.arskurs)

14.6.1 Targeting

Code
RItargeting(df.difex)

Svarskategorierna är “Mycket dåligt”,“Dåligt”,“Varken bra eller dåligt”,“Bra”,“Mycket bra”.

Den tydligaste skillnaden mellan de två subgrupperna är att tröskelvärdet mellan Dåligt och Varken bra eller dåligt (T2) för flickor gy 2 (item A1f2) är ungefär samma som mellan Varken bra eller dåligt och Bra (T3) för pojkar åk 7 (item A1p7).

14.6.2 Bra/Mycket bra

Code
df.erm <- PCM(df.difex)
dfin <- df.difex
xlim = c(-4,5)

item.estimates <- eRm::thresholds(df.erm)
  item_difficulty <- item.estimates[["threshtable"]][["1"]]
  item_difficulty <- as.data.frame(item_difficulty)
  item.se <- item.estimates$se.thresh
  person.locations.estimate <- person.parameter(df.erm)
   item.fit <- eRm::itemfit(person.locations.estimate)

  item.locations <- item_difficulty[, 2:ncol(item_difficulty)]
  names(item.locations) <- paste0("T", c(1:ncol(item.locations))) # re-number items
  itemloc.long <- item.locations %>%
    rownames_to_column() %>%
    dplyr::rename(names = "rowname") %>%
    mutate(names = factor(names, levels = rev(names(dfin)))) %>%
    pivot_longer(
      cols = starts_with("T"),
      names_to = "thresholds",
      values_to = "par_values"
    )
Code
### create df for ggplot histograms
  # person locations
  thetas <- as.data.frame(person.locations.estimate$theta.table)
  pthetas <- thetas$`Person Parameter`
  # item locations
  thresholds <- c()
  for (i in 2:ncol(item_difficulty)) {
    thresholds <- c(thresholds, item_difficulty[, i])
  }
  ### items and persons in the same variable
  #create data frame with 0 rows and 3 columns
  df.locations <- data.frame(matrix(ncol = 2, nrow = 0))
  # provide column names
  colnames(df.locations) <- c("type", "locations")
  # change type of data
  df.locations$type <- as.character(df.locations$type)
  df.locations$locations <- as.numeric(df.locations$locations)
  # insert labels in accurate amounts (N+items)
  nper <- nrow(dfin)
  nperp <- nper + 1
  nthr <- length(thresholds) + nper
  df.locations[1:nper, 1] <- paste0("Persons")
  df.locations[nperp:nthr, 1] <- paste0("Item thresholds")
  # insert data from vectors with thetas and thresholds
  df.locations$locations <- c(pthetas, thresholds)
  # change type to class factor
  df.locations$type <- as.factor(df.locations$type)

  # get mean/SD for item/person locations
  pi.locations <- data.frame(matrix(ncol = 3, nrow = 3))
Code
item.mean <- round(mean(item_difficulty$Location), 2)
  item.sd <- round(sd(item_difficulty$Location), 2)
  item.thresh.sd <- item_difficulty %>%
    dplyr::select(starts_with("Threshold")) %>%
    pivot_longer(everything()) %>%
    pull() %>%
    na.omit() %>%
    sd() %>%
    round(2)
  person.mean <- round(mean(pthetas), 2)
  person.sd <- round(sd(pthetas), 2)
  #provide column names
  colnames(pi.locations) <- c('','Mean', 'SD')
  pi.locations[1,1] <- "Items"
  pi.locations[1,2] <- round(mean(item_difficulty$Location),2)
  pi.locations[1,3] <- round(sd(item_difficulty$Location),2)
  pi.locations[2,1] <- "Item thresholds"
  pi.locations[2,2] <- round(mean(item_difficulty$Location),2)
  pi.locations[2,3] <- item.thresh.sd
  pi.locations[3,1] <- "Persons"
  pi.locations[3,2] <- round(mean(pthetas),2)
  pi.locations[3,3] <- round(sd(pthetas),2)
Code
# Person location histogram
  p2 <- df.locations %>% 
  filter(type == "Persons") %>% 
    ggplot() +
    geom_histogram(
      aes(locations, fill = "Persons", y = after_stat(count))
    ) +
    xlab("") +
    ylab("Persons") +
    scale_x_continuous(limits = xlim, breaks = scales::pretty_breaks(n = 10)) +
    geom_vline(xintercept = -0.8145551, color = "#0e4e65", linetype = 2) +
      geom_vline(xintercept = 0.2181891 , color = "orange", linetype = 2) +

    #annotate("rect", ymin = 0, ymax = Inf, xmin = (person.mean - person.sd), xmax = (person.mean + person.sd), alpha = .2) +
    theme_bw() +
    theme(
      legend.position = "none",
      text = element_text(family = "sans")
    )

# make plot with each items thresholds shown as dots

  p1 <- 
    itemloc.long %>% 
    filter(str_detect(names,"A1")) %>% 
    ggplot(aes(x = names, y = par_values, label = thresholds, color = names)) +
    geom_point() +
    geom_text(hjust = 1.1, vjust = 1) +
    ylab("Location (logit scale)") +
    xlab("Items") +
      geom_hline(yintercept = -0.8145551, color = "#0e4e65", linetype = 2) +
      geom_hline(yintercept = 0.2181891 , color = "orange", linetype = 2) +
    scale_y_continuous(limits = xlim, breaks = scales::pretty_breaks(n = 10)) +
    theme_bw() +
    theme(legend.position = "none") +
    coord_flip() +
    theme(plot.caption = element_text(hjust = 0, face = "italic"))
Code
plot_grid(p2,p1, labels=NULL, nrow = 2, align ="hv", rel_heights = c(1.4,1.4))

Skillnader på gränsvärden indikeras av streckade linjer.

Code
object <- PCM(df.difex)
xlim <- c(-4,4)
theta  <- seq(xlim[1], xlim[2], length.out = 111L)   # x-axis

plist.internal <- function(object, theta){

  X <- object$X
  mt_vek <- apply(X, 2L, max, na.rm = TRUE)   # number of categories - 1 for each item
  mt_ind <- rep(seq_along(mt_vek), mt_vek)

  #--------compute list matrix of probabilites for fixed theta)
  p.list <- tapply(object$betapar, mt_ind, function(beta.i){
    beta.i <- c(0, beta.i)
    ind.h <- 0:(length(beta.i)-1)
    theta.h <- tcrossprod(ind.h, theta) # ind.h %*% t(theta) # multiply category with
    tb <- exp(theta.h + beta.i)
    denom <- colSums(tb)
    pi.mat <- apply(tb, 1L, function(y){ y/denom })
    return(pi.mat)
  })
  return(p.list)
}

p.list <- plist.internal(object, theta)              # matrix of probabilities
th.ord <- order(theta)

textlab <- colnames(object$X)
ivec <- seq_along(p.list)
Code
# choose item number
yp <- as.matrix(p.list[[12]]) # A1p7
yy <- yp[th.ord,]

# plot objects
x = sort(theta) # vector for x axis
y = yp[th.ord,] # matrix with one vector per response category
ylim = c(0,1)
xlim = c(-4,4)

df.icc <- data.frame(matrix(ncol = 0, nrow = 111))
df.icc <- rbind(df.icc,as.data.frame(y))
df.icc$x <- sort(theta)

categories <- c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra")

df.icc <- df.icc %>%
  pivot_longer(!x) %>%
  rename(Category = name,
         Probability = value)

# choose item number
yp <- as.matrix(p.list[[13]]) # A1f2
yy <- yp[th.ord,]

# plot objects
x = sort(theta) # vector for x axis
y = yp[th.ord,] # matrix with one vector per response category
ylim = c(0,1)
xlim = c(-4,4)

df.iccF2 <- data.frame(matrix(ncol = 0, nrow = 111))
df.iccF2 <- rbind(df.iccF2,as.data.frame(y))
df.iccF2$x <- sort(theta)

categories <- c("Mycket dåligt","Dåligt","Varken bra eller dåligt","Bra","Mycket bra")

df.iccF2 <- df.iccF2 %>%
  pivot_longer(!x) %>%
  rename(Category = name,
         Probability = value)

14.6.3 Figur Flickor gy 2

Code
ggplot(data = df.iccF2, aes(x = x, y = Probability, color = Category, group = Category)) +
  #geom_point(data = df.iccF2, size = 0.2, alpha = 0.3) +
  geom_line() +
  scale_x_continuous('Person Location') +
  scale_y_continuous(limits = c(0,1)) +
  scale_color_brewer(type = "qual", palette = "Dark2",
                     labels = categories) +
  theme_minimal() +
  theme_rise() +
  labs(title = "Hur mår du rent allmänt?",
       subtitle = "Flickor gy 2")

14.6.4 Figur Pojkar åk 7

Code
ggplot(data = df.icc, aes(x = x, y = Probability, color = Category, group = Category)) +
  geom_line() +
  scale_x_continuous('Person Location') +
  scale_y_continuous(limits = c(0,1)) +
  scale_color_brewer(type = "qual", palette = "Dark2",
                     labels = categories) +
  theme_minimal() +
  theme_rise() +
  labs(title = "Hur mår du rent allmänt?",
       subtitle = "Pojkar åk 7")

14.6.5 Gemensam figur

Code
ggplot(data = df.icc, aes(x = x, y = Probability, color = Category, group = Category)) +
  geom_point(data = df.iccF2, size = 0.2, alpha = 0.3) +
  geom_line() +
  scale_x_continuous('Person Location') +
  scale_y_continuous(limits = c(0,1)) +
  scale_color_brewer(type = "qual", palette = "Dark2",
                     labels = categories) +
  theme_minimal() +
  theme_rise() +
  labs(title = "Hur mår du rent allmänt?",
    caption = "Streckad linje = Flickor gy 2. Heldragen linje = Pojkar åk 7")

15 Programvara som använts för analyserna

Code
pkgs <- cite_packages(cite.tidyverse = TRUE, 
                      output = "table",
                      bib.file = "grateful-refs.bib",
                      include.RStudio = TRUE,
                      out.dir = getwd())
formattable(pkgs, 
            table.attr = 'class=\"table table-striped\" style="font-size: 14px; font-family: Lato; width: 80%"')
Package Version Citation
arrow 12.0.1.1 Richardson et al. (2023)
base 4.2.3 R Core Team (2023)
car 3.1.2 Fox and Weisberg (2019)
colorspace 2.1.0 Zeileis, Hornik, and Murrell (2009); Stauffer et al. (2009); Zeileis et al. (2020)
cowplot 1.1.1 Wilke (2020)
eRm 1.0.2 Mair and Hatzinger (2007b); Mair and Hatzinger (2007a); Hatzinger and Rusch (2009); Rusch, Maier, and Hatzinger (2013); Koller, Maier, and Hatzinger (2015); Debelak and Koller (2019); Mair, Hatzinger, and Maier (2021)
foreach 1.5.2 Microsoft and Weston (2022)
formattable 0.2.1 Ren and Russell (2021)
furrr 0.3.1 Vaughan and Dancho (2022)
ggdist 3.3.0 Kay (2023)
ggiraph 0.8.7 Gohel and Skintzos (2023)
ggpp 0.5.4 Aphalo (2023)
ggrepel 0.9.3 Slowikowski (2023)
glue 1.6.2 Hester and Bryan (2022)
kableExtra 1.3.4 Zhu (2021)
knitr 1.42 Xie (2014); Xie (2015); Xie (2023)
matrixStats 0.63.0 Bengtsson (2022)
mirt 1.40 Chalmers (2012)
psych 2.3.6 William Revelle (2023)
psychotree 0.16.0 Trepte and Verbeet (2010); Strobl, Wickelmaier, and Zeileis (2011); Strobl, Kopf, and Zeileis (2015); Komboz, Zeileis, and Strobl (2018); Wickelmaier and Zeileis (2018)
reshape 0.8.9 Wickham (2007)
RISEkbmRasch 0.1.20.0 Johansson (2023)
rmarkdown 2.22 Xie, Allaire, and Grolemund (2018); Xie, Dervieux, and Riederer (2020); Allaire et al. (2023)
scales 1.2.1 Wickham and Seidel (2022)
tidyverse 2.0.0 Wickham et al. (2019)

16 Referenser

Allaire, JJ, Yihui Xie, Christophe Dervieux, Jonathan McPherson, Javier Luraschi, Kevin Ushey, Aron Atkins, et al. 2023. rmarkdown: Dynamic Documents for r. https://github.com/rstudio/rmarkdown.
Aphalo, Pedro J. 2023. ggpp: Grammar Extensions to ggplot2. https://CRAN.R-project.org/package=ggpp.
Bengtsson, Henrik. 2022. matrixStats: Functions That Apply to Rows and Columns of Matrices (and to Vectors). https://CRAN.R-project.org/package=matrixStats.
Chalmers, R. Philip. 2012. mirt: A Multidimensional Item Response Theory Package for the R Environment.” Journal of Statistical Software 48 (6): 1–29. https://doi.org/10.18637/jss.v048.i06.
Debelak, Rudolf, and Ingrid Koller. 2019. Testing the Local Independence Assumption of the Rasch Model With Q3-Based Nonparametric Model Tests.” Applied Psychological Measurement. https://doi.org/10.1177/0146621619835501.
Fox, John, and Sanford Weisberg. 2019. An R Companion to Applied Regression. Third. Thousand Oaks CA: Sage. https://socialsciences.mcmaster.ca/jfox/Books/Companion/.
Gohel, David, and Panagiotis Skintzos. 2023. ggiraph: Make ggplot2 Graphics Interactive. https://CRAN.R-project.org/package=ggiraph.
Hatzinger, Reinhold, and Thomas Rusch. 2009. IRT models with relaxed assumptions in eRm: A manual-like instruction.” Psychology Science Quarterly 51.
Hester, Jim, and Jennifer Bryan. 2022. glue: Interpreted String Literals. https://CRAN.R-project.org/package=glue.
Johansson, Magnus. 2023. RISEkbmRasch: Psychometric Analysis in r with Rasch Measurement Theory. https://github.com/pgmj/RISEkbmRasch.
Kay, Matthew. 2023. ggdist: Visualizations of Distributions and Uncertainty. https://doi.org/10.5281/zenodo.3879620.
Koller, Ingrid, Marco Johannes Maier, and Reinhold Hatzinger. 2015. An Empirical Power Analysis of Quasi-Exact Tests for the Rasch Model: Measurement Invariance in Small Samples.” Methodology 11. https://doi.org/10.1027/1614-2241/a000090.
Komboz, Basil, Achim Zeileis, and Carolin Strobl. 2018. “Tree-Based Global Model Tests for Polytomous Rasch Models.” Educational and Psychological Measurement 78 (1): 128–66. https://doi.org/10.1177/0013164416664394.
Mair, Patrick, and Reinhold Hatzinger. 2007a. CML based estimation of extended Rasch models with the eRm package in R.” Psychology Science 49.
———. 2007b. Extended Rasch modeling: The eRm package for the application of IRT models in R.” Journal of Statistical Software 20. https://www.jstatsoft.org/v20/i09.
Mair, Patrick, Reinhold Hatzinger, and Marco Johannes Maier. 2021. eRm: Extended Rasch Modeling. https://cran.r-project.org/package=eRm.
Microsoft, and Steve Weston. 2022. foreach: Provides Foreach Looping Construct. https://CRAN.R-project.org/package=foreach.
R Core Team. 2023. R: A Language and Environment for Statistical Computing. Vienna, Austria: R Foundation for Statistical Computing. https://www.R-project.org/.
Ren, Kun, and Kenton Russell. 2021. formattable: Create Formattable Data Structures. https://CRAN.R-project.org/package=formattable.
Richardson, Neal, Ian Cook, Nic Crane, Dewey Dunnington, Romain François, Jonathan Keane, Dragoș Moldovan-Grünfeld, Jeroen Ooms, and Apache Arrow. 2023. arrow: Integration to Apache Arrow. https://CRAN.R-project.org/package=arrow.
Rusch, Thomas, Marco Johannes Maier, and Reinhold Hatzinger. 2013. Linear logistic models with relaxed assumptions in R.” In Algorithms from and for Nature and Life, edited by Berthold Lausen, Dirk van den Poel, and Alfred Ultsch. Studies in Classification, Data Analysis, and Knowledge Organization. New York: Springer. https://doi.org/10.1007/978-3-319-00035-0_34.
Slowikowski, Kamil. 2023. ggrepel: Automatically Position Non-Overlapping Text Labels with ggplot2. https://CRAN.R-project.org/package=ggrepel.
Stauffer, Reto, Georg J. Mayr, Markus Dabernig, and Achim Zeileis. 2009. “Somewhere over the Rainbow: How to Make Effective Use of Colors in Meteorological Visualizations.” Bulletin of the American Meteorological Society 96 (2): 203–16. https://doi.org/10.1175/BAMS-D-13-00155.1.
Strobl, Carolin, Julia Kopf, and Achim Zeileis. 2015. “Rasch Trees: A New Method for Detecting Differential Item Functioning in the Rasch Model.” Psychometrika 80 (2): 289–316. https://doi.org/10.1007/s11336-013-9388-3.
Strobl, Carolin, Florian Wickelmaier, and Achim Zeileis. 2011. “Accounting for Individual Differences in Bradley-Terry Models by Means of Recursive Partitioning.” Journal of Educational and Behavioral Statistics 36 (2): 135–53. https://doi.org/10.3102/1076998609359791.
Trepte, Sabine, and Markus Verbeet, eds. 2010. Allgemeinbildung in Deutschland – Erkenntnisse Aus Dem SPIEGEL Studentenpisa-Test. Wiesbaden: VS Verlag.
Vaughan, Davis, and Matt Dancho. 2022. furrr: Apply Mapping Functions in Parallel Using Futures. https://CRAN.R-project.org/package=furrr.
Wickelmaier, Florian, and Achim Zeileis. 2018. “Using Recursive Partitioning to Account for Parameter Heterogeneity in Multinomial Processing Tree Models.” Behavior Research Methods 50 (3): 1217–33. https://doi.org/10.3758/s13428-017-0937-z.
Wickham, Hadley. 2007. “Reshaping Data with the Reshape Package.” Journal of Statistical Software 21 (12). https://www.jstatsoft.org/v21/i12/.
Wickham, Hadley, Mara Averick, Jennifer Bryan, Winston Chang, Lucy D’Agostino McGowan, Romain François, Garrett Grolemund, et al. 2019. “Welcome to the tidyverse.” Journal of Open Source Software 4 (43): 1686. https://doi.org/10.21105/joss.01686.
Wickham, Hadley, and Dana Seidel. 2022. scales: Scale Functions for Visualization. https://CRAN.R-project.org/package=scales.
Wilke, Claus O. 2020. cowplot: Streamlined Plot Theme and Plot Annotations for ggplot2. https://CRAN.R-project.org/package=cowplot.
William Revelle. 2023. psych: Procedures for Psychological, Psychometric, and Personality Research. Evanston, Illinois: Northwestern University. https://CRAN.R-project.org/package=psych.
Xie, Yihui. 2014. knitr: A Comprehensive Tool for Reproducible Research in R.” In Implementing Reproducible Computational Research, edited by Victoria Stodden, Friedrich Leisch, and Roger D. Peng. Chapman; Hall/CRC.
———. 2015. Dynamic Documents with R and Knitr. 2nd ed. Boca Raton, Florida: Chapman; Hall/CRC. https://yihui.org/knitr/.
———. 2023. knitr: A General-Purpose Package for Dynamic Report Generation in r. https://yihui.org/knitr/.
Xie, Yihui, J. J. Allaire, and Garrett Grolemund. 2018. R Markdown: The Definitive Guide. Boca Raton, Florida: Chapman; Hall/CRC. https://bookdown.org/yihui/rmarkdown.
Xie, Yihui, Christophe Dervieux, and Emily Riederer. 2020. R Markdown Cookbook. Boca Raton, Florida: Chapman; Hall/CRC. https://bookdown.org/yihui/rmarkdown-cookbook.
Zeileis, Achim, Jason C. Fisher, Kurt Hornik, Ross Ihaka, Claire D. McWhite, Paul Murrell, Reto Stauffer, and Claus O. Wilke. 2020. colorspace: A Toolbox for Manipulating and Assessing Colors and Palettes.” Journal of Statistical Software 96 (1): 1–49. https://doi.org/10.18637/jss.v096.i01.
Zeileis, Achim, Kurt Hornik, and Paul Murrell. 2009. “Escaping RGBland: Selecting Colors for Statistical Graphics.” Computational Statistics & Data Analysis 53 (9): 3259–70. https://doi.org/10.1016/j.csda.2008.11.033.
Zhu, Hao. 2021. kableExtra: Construct Complex Table with kable and Pipe Syntax. https://CRAN.R-project.org/package=kableExtra.

Reuse